--- Test properties of the 'Data.Array' module
module tests.qc.Array where

import frege.Prelude hiding(Object, !!)

import Data.Ix
import Data.Array as A
import Data.Array as A(!!)
import Test.QuickCheck as Q public

intBounds :: Gen (Int, Int)
intBounds = do
    a <- choose (0, 100)
    b <- choose (0, 100)
    return (a,a+b)

charBounds :: Gen (Char, Char)
charBounds = do
    a <- elements ['a'..'m']
    b <- elements ['l'..'z'] -- 'm' and 'l' makes empty bounds
    return (a,b)

emptyRange = elements [(42,41)]

checkBounds :: (Ix i, Show i) => (Gen (i, i)) -> Property
checkBounds g = forAll g (\b -> (array b []).bounds == b)

checkElems :: (Show a, Eq a) =>[a] -> Bool
checkElems a = (listArray (1, length a) a).elems == a

checkIndices :: (Enum i, Show i, Ix i) => (i,i) -> Bool
checkIndices (l,u) = let i = (array (l,u) []).indices
                     in if (l<=u) then i == [l..u] else i == []

checkIndicesGen :: (Enum i, Show i, Ix i) => Gen (i,i) -> Property
checkIndicesGen g = forAll g checkIndices

-- helper for crating one-based indexed Arrays
mkNaturallyIndexArr elems = listArray (1, length elems) elems

checkFoldrSum elems = foldrElems (+) 0 (mkNaturallyIndexArr elems) == sum elems

checkFoldrSumStrict elems = foldrElems' (+) 0 (mkNaturallyIndexArr elems) == sum elems

checkFoldlSum elems = foldlElems (+) 0 (mkNaturallyIndexArr elems) == sum elems

checkFoldlSumStrict elems = foldlElems' (+) 0 (mkNaturallyIndexArr elems) == sum elems

checkFoldr1Sum elems = elems == [] || foldr1Elems (+) (mkNaturallyIndexArr elems) == sum elems

checkFoldl1Sum elems = elems == [] || foldl1Elems (+) (mkNaturallyIndexArr elems) == sum elems

checkFmap elems = (fmap (*2) (mkNaturallyIndexArr elems)).elems == map (*2) elems

checkEq elems = (mkNaturallyIndexArr elems) == (mkNaturallyIndexArr elems)

checkAccumArray elems = accumArray (+) 0 bounds (assocs++assocs) == listArray bounds (map (*2) elems)
                        where n = length elems
                              bounds = (1,n)
                              assocs = zip [1..n] elems

checkIxmap = (ixmap ('a','z') ord (array (97, 122) elems)) == array ('a','z') [(a, ord a) | a<-['a'..'z']]
                where elems = map (\x->(x, x)) [97..122]

checkCmp (e1,e2) = (e1 <=> e2) == ((mkNaturallyIndexArr e1) <=> (mkNaturallyIndexArr e2))

p_boundEmpty        = once (checkBounds emptyRange)
p_boundChars        = property (checkBounds charBounds)
p_boundInts         = property (checkBounds intBounds)
p_elemsChars        = property (checkElems::[Char]->Bool)
p_elemsInts         = property (checkElems::[Int]->Bool)
p_elemsStrings      = property (checkElems::[String]->Bool)
p_indicesChars      = property (checkIndices::(Char,Char)->Bool)
p_indicesInts       = property (checkIndicesGen intBounds)
p_twoDimensional    = once ((listArray (('a',false),('b',true)) [0,1,2,3]).assocs == [(('a',false),0),(('a',true),1),(('b',false),2),(('b',true),3)])
p_undefinedAreLazy  = once ((array (1,2) [(2,true)] !! 2) == true)
p_foldr             = property (checkFoldrSum :: [Int] -> Bool)
p_foldrStrict       = property (checkFoldrSumStrict :: [Int] -> Bool)
p_foldl             = property (checkFoldlSum :: [Int] -> Bool)
p_foldlStrict       = property (checkFoldlSumStrict :: [Int] -> Bool)
p_foldr1            = property (checkFoldr1Sum :: [Int] -> Bool)
p_foldl1            = property (checkFoldl1Sum :: [Int] -> Bool)
p_fmap              = property checkFmap
p_eq                = property (checkEq :: [Char] -> Bool)
p_accumArray        = property (checkAccumArray :: [Int] -> Bool)
p_ixmap             = once checkIxmap
p_updated           = once (mkNaturallyIndexArr [1,2,3] // [(1,0),(3,0)] == mkNaturallyIndexArr [0,2,0])
p_cmp               = property (checkCmp :: ([Char], [Char])-> Bool)


-- STArray tests

newSTArrayInitialElements :: Bool
newSTArrayInitialElements =
    ST.run do
            arr <- STArray.new (1,3) "A"
            e1 <- arr.read 1
            e2 <- arr.read 2
            e3 <- arr.read 3
            return $ (e1,e2,e3) == ("A","A","A")

writeSTArray :: Bool
writeSTArray =
    ST.run do
            arr <- STArray.new (1,2) "A"
            e1_1 <- arr.read 1
            _ <- arr.write 1 "B"
            e1_2 <- arr.read 1
            e2_1 <- arr.read 2
            return $ (e1_1,e1_2,e2_1) == ("A","B","A")

readFromArrayWithUndefinedElem :: Bool
readFromArrayWithUndefinedElem =
        ST.run do
                arr <- thawSTArray $ array (1,3) [(1,1),(3,100)] -- 2 is undefined
                e1 <- arr.read 1
                e3 <- arr.read 3
                return (e1+e3 == 101)

thawAndFreeze :: [Int] -> Bool
thawAndFreeze elems =
        let a = mkNaturallyIndexArr elems
        in ST.run do
                stArr <- thawSTArray a
                freezed <- freezeSTArray stArr
                return $ freezed == a

newEmptyArray :: Bool
newEmptyArray =
    ST.run do
            arr <- STArray.new (1,0) undefined
            return $ arr.numElements == 0

updateUndefinedElem :: Bool
updateUndefinedElem =
    ST.run do
            arr <- STArray.new (1,1) (undefined::Int)
            _ <- arr.write 1 42
            v <- arr.read 1
            return $ v == 42

boundsSTArray :: (Show i, Ix i) => (i,i) -> Bool
boundsSTArray b =
    b == ST.run do
            arr <- STArray.new b (undefined::Int)
            return arr.bounds

numElementsSTArray :: (Show i, Ix i) => (i,i) -> Bool
numElementsSTArray b =
    Ix.rangeSize b == ST.run do
            arr <- STArray.new b (undefined::Int)
            return arr.numElements

p_newSTArrayInitialElements         = once newSTArrayInitialElements
p_writeSTArray                      = once writeSTArray
p_readFromArrayWithUndefinedElem    = once readFromArrayWithUndefinedElem
p_thawAndFreeze                     = property thawAndFreeze
p_newEmptyArray                     = once newEmptyArray
p_updateUndefinedElem               = once updateUndefinedElem
p_boundsSTArray                     = property (forAll intBounds boundsSTArray)
p_numElementsSTArray                = property (forAll intBounds numElementsSTArray)
